home *** CD-ROM | disk | FTP | other *** search
- ;;;
- ;;; Copyright (c) 1985 Massachusetts Institute of Technology
- ;;;
- ;;; This material was developed by the Scheme project at the
- ;;; Massachusetts Institute of Technology, Department of
- ;;; Electrical Engineering and Computer Science. Permission to
- ;;; copy this software, to redistribute it, and to use it for any
- ;;; purpose is granted, subject to the following restrictions and
- ;;; understandings.
- ;;;
- ;;; 1. Any copy made of this software must include this copyright
- ;;; notice in full.
- ;;;
- ;;; 2. Users of this software agree to make their best efforts (a)
- ;;; to return to the MIT Scheme project any improvements or
- ;;; extensions that they make, so that these may be included in
- ;;; future releases; and (b) to inform MIT of noteworthy uses of
- ;;; this software.
- ;;;
- ;;; 3. All materials developed as a consequence of the use of
- ;;; this software shall duly acknowledge such use, in accordance
- ;;; with the usual standards of acknowledging credit in academic
- ;;; research.
- ;;;
- ;;; 4. MIT has made no warrantee or representation that the
- ;;; operation of this software will be error-free, and MIT is
- ;;; under no obligation to provide any services, by way of
- ;;; maintenance, update, or otherwise.
- ;;;
- ;;; 5. In conjunction with products arising from the use of this
- ;;; material, there shall be no use of the name of the
- ;;; Massachusetts Institute of Technology nor of any adaptation
- ;;; thereof in any advertising, promotional, or sales literature
- ;;; without prior written consent from MIT in each case.
- ;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;
- ;;; Modified by Texas Instruments Inc 8/15/85
- ;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- ;;;; Searches
-
- ;;; **** For the time being all search and match operations are case
- ;;; insensitive. This needs to be fixed later. Also, the code has
- ;;; been bummed to know that strings are implemented as vectors of
- ;;; ASCII, and that char-sets are implemented as vectors of numbers.
-
- ;;;; Character Search
-
- (define (make-find-next-char substring-find-next-char)
- (lambda (start end char)
- (let ((start-line (mark-line start))
- (end-line (mark-line end)))
- (define (loop line)
- (if (eq? line end-line)
- (let ((index
- (substring-find-next-char (line-string line)
- 0
- (mark-position end)
- char)))
- (and index (make-mark line index)))
- (or (let ((index
- (substring-find-next-char (line-string line)
- 0
- (line-length line)
- char)))
- (and index (make-mark line index)))
- (loop (line-next line)))))
- (cond ((char=? #\newline char)
- (and (not (eq? start-line end-line))
- (make-mark start-line (line-length start-line))))
- ((eq? start-line end-line)
- (let ((index
- (substring-find-next-char (line-string start-line)
- (mark-position start)
- (mark-position end)
- char)))
- (and index (make-mark start-line index))))
- (else
- (or (let ((index
- (substring-find-next-char (line-string start-line)
- (mark-position start)
- (line-length start-line)
- char)))
- (and index (make-mark start-line index)))
- (loop (line-next start-line))))))))
-
- (define find-next-char
- (make-find-next-char substring-find-next-char-ci))
-
- (define (find-next-newline start end)
- (and (not (eq? (mark-line start) (mark-line end)))
- (make-mark (mark-line start) (line-length (mark-line start)))))
-
- (define (make-find-previous-char substring-find-previous-char)
- (lambda (start end char)
- ;; Here START must come after END in the mark ordering.
- ;; The search begins at START and proceeds back until END.
- (let ((start-line (mark-line start))
- (end-line (mark-line end)))
- (define (loop line)
- (if (eq? line end-line)
- (let ((index
- (substring-find-previous-char (line-string line)
- (mark-position end)
- (line-length line)
- char)))
- (and index (make-mark line (1+ index))))
- (let ((index
- (substring-find-previous-char (line-string line)
- 0
- (line-length line)
- char)))
- (if index
- (make-mark line (1+ index))
- (loop (line-previous line))))))
- (cond ((char=? #\newline char))
- ((eq? start-line end-line)
- (let ((index
- (substring-find-previous-char (line-string start-line)
- (mark-position end)
- (mark-position start)
- char)))
- (and index (make-mark start-line (1+ index)))))
- (else
- (let ((index
- (substring-find-previous-char (line-string start-line)
- 0
- (mark-position start)
- char)))
- (if index
- (make-mark start-line (1+ index))
- (loop (line-previous start-line)))))))))
-
- (define find-previous-char
- (make-find-previous-char substring-find-previous-char-ci))
-
- (define (find-previous-newline start end)
- (and (not (eq? (mark-line start) (mark-line end)))
- (make-mark (mark-line start) 0)))
-
- ;;;; Character-set Search
-
- (define ((char-set-forward-search char-set) start end limit?)
- (or (find-next-char-in-set start end char-set)
- (limit-mark-motion limit? end)))
-
- (define ((char-set-backward-search char-set) start end limit?)
- (or (find-previous-char-in-set start end char-set)
- (limit-mark-motion limit? end)))
-
- (define (find-next-char-in-set start end char-set)
- (let ((line (mark-line start))
- (position (mark-position start))
- (end-line (mark-line end))
- (char-set-length (string-length char-set)))
- (define (loop line)
- (if (eq? line end-line)
- (let ((index
- (substring-find-next-char-in-set (line-string line)
- 0
- (mark-position end)
- char-set)))
- (and index (make-mark line index)))
- (or (let ((index
- (substring-find-next-char-in-set (line-string line)
- 0
- (line-length line)
- char-set)))
- (and index (make-mark line index)))
- (loop (line-next line)))))
- (if (eq? line end-line)
- (let ((index
- (substring-find-next-char-in-set (line-string line)
- position
- (mark-position end)
- char-set)))
- (and index (make-mark line index)))
- (or (let ((index
- (substring-find-next-char-in-set (line-string line)
- position
- (line-length line)
- char-set)))
- (and index (make-mark line index)))
- ;;; (if (char-set-member? char-set #\Newline)
- (if (substring-find-next-char-in-set char-set 0 char-set-length
- #\newline)
- (make-mark line (line-length line))
- (loop (line-next line)))))))
-
- (define (find-previous-char-in-set start end char-set)
- ;; Here START must come after END in the mark ordering.
- ;; The search begins at START and proceeds back until END.
- (let ((line (mark-line start))
- (position (mark-position start))
- (end-line (mark-line end))
- (char-set-length (string-length char-set)))
- (define (loop line)
- (if (eq? line end-line)
- (let ((index
- (substring-find-previous-char-in-set (line-string line)
- (mark-position end)
- (line-length line)
- char-set)))
- (and index (make-mark line (1+ index))))
- (or (let ((index
- (substring-find-previous-char-in-set (line-string line)
- 0
- (line-length line)
- char-set)))
- (and index (make-mark line (1+ index))))
- (loop (line-previous line)))))
- (if (eq? line end-line)
- (let ((index
- (substring-find-previous-char-in-set (line-string line)
- (mark-position end)
- position
- char-set)))
- (and index (make-mark line (1+ index))))
- (or (let ((index
- (substring-find-previous-char-in-set (line-string line)
- 0
- position
- char-set)))
- (and index (make-mark line (1+ index))))
- ;;; (if (char-set-member? char-set #\Newline)
- (if (substring-find-next-char-in-set char-set 0 char-set-length
- #\newline)
- (make-mark line 0)
- (loop (line-previous line)))))))
-
-
- ;;;; String Search
-
- (define (find-next-string start-mark end-mark string)
- (find-next-substring start-mark end-mark
- string 0 (string-length string)))
-
- (define (find-next-substring start-mark end-mark
- string start end)
- (if (= start end)
- start-mark
- (let ((start-bound (mark- end-mark (-1+ (- end start)) #F)))
- (define (find-first mark)
- (let ((first-char (find-next-char mark start-bound
- (string-ref string start))))
- (and first-char
- (if (match-next-substring first-char end-mark
- string start end)
- first-char
- (find-first (mark1+ first-char #F))))))
- (and start-bound
- (mark< start-mark start-bound)
- (find-first start-mark)))))
-
- (define (find-previous-string start-mark end-mark string)
- (find-previous-substring start-mark end-mark
- string 0 (string-length string)))
-
- (define (find-previous-substring start-mark end-mark
- string start end)
- (if (= start end)
- start-mark
- (let ((start-bound (mark+ end-mark (-1+ (- end start)) #F)))
- (define (find-first mark)
- (let ((first-char
- (find-previous-char mark start-bound
- (string-ref string (-1+ end)))))
- (and first-char
- (if (match-previous-substring first-char end-mark
- string start end)
- first-char
- (find-first (mark-1+ first-char #F))))))
- (and start-bound
- (mark> start-mark start-bound)
- (find-first start-mark)))))
-
- ;;;; String Match
-
- (define (match-next-strings start end strings)
- (define (loop strings)
- (and (not (null? strings))
- (or (match-next-string start end (car strings))
- (loop (cdr strings)))))
- (loop strings))
-
- (define (match-next-string start end string)
- (match-next-substring start end string 0 (string-length string)))
-
- (define (substring-next-newlines string start end)
- (define (loop start)
- (let ((newline (substring-find-next-char string start end #\newline)))
- (if (not newline)
- (list (- end start))
- (cons newline (loop (1+ newline))))))
- (loop start))
-
- (define (match-previous-strings start end strings)
- (define (loop strings)
- (and (not (null? strings))
- (or (match-previous-string start end (car strings))
- (loop (cdr strings)))))
- (loop strings))
-
- (define (match-previous-string start end string)
- (match-previous-substring start end string 0 (string-length string)))
-
- (define (substring-previous-newlines string start end)
- (define (loop end)
- (let ((newline
- (substring-find-previous-char string start end #\newline)))
- (if (not newline)
- (list (- end start))
- (cons (1+ newline) (loop newline)))))
- (loop end))
-
- (define (match-next-substring start-mark end-mark string start end)
- (let ((newlines (substring-next-newlines string start end))
- (start-line (mark-line start-mark))
- (start-position (mark-position start-mark))
- (end-line (mark-line end-mark))
- (end-position (mark-position end-mark)))
- (define (match-rest line start newlines)
- (cond ((eq? line end-line)
- (and (null? (cdr newlines))
- (<= (car newlines) end-position)
- (substring-equal-ci? string start end
- (line-string line) 0
- (car newlines))
- (make-mark line (car newlines))))
- ((null? (cdr newlines))
- (and (<= (car newlines) (line-length line))
- (substring-equal-ci? string start end
- (line-string line) 0
- (car newlines))
- (make-mark line (car newlines))))
- (else
- (and (substring-equal-ci? string start (car newlines)
- (line-string line) 0
- (line-length line))
- (match-rest (line-next line)
- (1+ (car newlines))
- (cdr newlines))))))
-
- (cond ((eq? start-line end-line)
- (and (null? (cdr newlines))
- (let ((end-position* (+ start-position (car newlines))))
- (and (<= end-position* end-position)
- (substring-equal-ci? string start end
- (line-string start-line)
- start-position
- end-position*)
- (make-mark start-line end-position*)))))
- ((null? (cdr newlines))
- (let ((end-position* (+ start-position (car newlines))))
- (and (<= end-position* (line-length start-line))
- (substring-equal-ci? string start end
- (line-string start-line)
- start-position
- end-position*)
- (make-mark start-line end-position*))))
- (else
- (and (substring-equal-ci? string start (car newlines)
- (line-string start-line)
- start-position
- (line-length start-line))
- (match-rest (line-next start-line)
- (1+ (car newlines))
- (cdr newlines)))))))
-
- (define (match-previous-substring start-mark end-mark string start end)
- ;; Here START-MARK must come after END-MARK in the mark ordering.
- ;; The match begins at START-MARK and proceeds back until END-MARK.
- (let ((newlines (substring-previous-newlines string start end))
- (start-line (mark-line start-mark))
- (start-position (mark-position start-mark))
- (end-line (mark-line end-mark))
- (end-position (mark-position end-mark)))
- (define (match-rest line end newlines)
- (cond ((eq? line end-line)
- (and (null? (cdr newlines))
- (<= end-position (car newlines))
- (substring-equal-ci? string start end
- (line-string line) (car newlines)
- (line-length line))
- (make-mark line (car newlines))))
- ((null? (cdr newlines))
- (and (<= 0 (car newlines))
- (substring-equal-ci? string start end
- (line-string line) (car newlines)
- (line-length line))
- (make-mark line (car newlines))))
- (else
- (and (substring-equal-ci? string (car newlines) end
- (line-string line) 0
- (line-length line))
- (match-rest (line-next line)
- (-1+ (car newlines))
- (cdr newlines))))))
-
- (cond ((eq? start-line end-line)
- (and (null? (cdr newlines))
- (let ((end-position* (- start-position (car newlines))))
- (and (<= end-position end-position*)
- (substring-equal-ci? string start end
- (line-string start-line)
- end-position* start-position)
- (make-mark start-line end-position*)))))
- ((null? (cdr newlines))
- (let ((end-position* (- start-position (car newlines))))
- (and (<= 0 end-position*)
- (substring-equal-ci? string start end
- (line-string start-line)
- end-position* start-position)
- (make-mark start-line end-position*))))
- (else
- (and (substring-equal-ci? string (car newlines) end
- (line-string start-line) 0
- start-position)
- (match-rest (line-next start-line)
- (-1+ (car newlines))
- (cdr newlines)))))))
-
- ;;;; Character Match
-
- (define (match-next-char start end char)
- (and (mark< start end)
- (let ((line (mark-line start))
- (position (mark-position start)))
- (if (= position (line-length line))
- (and (char=? char #\newline)
- (make-mark (line-next line) 0))
- (and (char=? char (string-ref (line-string line) position))
- (make-mark line (1+ position)))))))
-
- (define (match-previous-char start end char)
- (and (mark> start end)
- (let ((line (mark-line start))
- (position (-1+ (mark-position start))))
- (if (negative? position)
- (and (char=? char #\newline)
- (make-mark (line-previous line)
- (line-length (line-previous line))))
- (and (char=? char (string-ref (line-string line) position))
- (make-mark line position))))))
-
- (define (match-next-char-in-set start end char-set)
- (and (mark< start end)
- (char-set-member? char-set (mark-right-char start))
- (mark1+ start #F)))
-
- (define (match-previous-char-in-set start end char-set)
- (and (mark> start end)
- (char-set-member? char-set (mark-left-char start))
- (mark-1+ start #F)))
-
-